home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / defcombin.lisp < prev    next >
Lisp/Scheme  |  1992-12-21  |  15KB  |  431 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package :pcl)
  29.  
  30. ;;;
  31. ;;; DEFINE-METHOD-COMBINATION
  32. ;;;
  33.  
  34. (defmacro define-method-combination (&whole form &rest args)
  35.   (declare (ignore args))
  36.   (if (and (cddr form)
  37.        (listp (caddr form)))
  38.       (expand-long-defcombin form)
  39.       (expand-short-defcombin form)))
  40.  
  41.  
  42. ;;;
  43. ;;; STANDARD method combination
  44. ;;;
  45. ;;; The STANDARD method combination type is implemented directly by the class
  46. ;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
  47. ;;; standard method combination directly and is defined by hand in the file
  48. ;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
  49. ;;; file for bootstrapping reasons.
  50. ;;;
  51. ;;; A commented out copy of this definition appears in combin.lisp.
  52. ;;; If you change this definition here, be sure to change it there
  53. ;;; also.
  54. ;;;
  55. (defmethod find-method-combination ((generic-function generic-function)
  56.                     (type (eql 'standard))
  57.                     options)
  58.   (when options
  59.     (method-combination-error
  60.       "The method combination type STANDARD accepts no options."))
  61.   *standard-method-combination*)
  62.  
  63.  
  64.  
  65. ;;;
  66. ;;; short method combinations
  67. ;;;
  68. ;;; Short method combinations all follow the same rule for computing the
  69. ;;; effective method.  So, we just implement that rule once.  Each short
  70. ;;; method combination object just reads the parameters out of the object
  71. ;;; and runs the same rule.
  72. ;;;
  73. ;;;
  74. (defclass short-method-combination (standard-method-combination)
  75.      ((operator
  76.     :reader short-combination-operator
  77.     :initarg :operator)
  78.       (identity-with-one-argument
  79.     :reader short-combination-identity-with-one-argument
  80.     :initarg :identity-with-one-argument))
  81.   (:predicate-name short-method-combination-p))
  82.  
  83. (defun expand-short-defcombin (whole)
  84.   (let* ((type (cadr whole))
  85.      (documentation
  86.        (getf (cddr whole) :documentation ""))
  87.      (identity-with-one-arg
  88.        (getf (cddr whole) :identity-with-one-argument nil))
  89.      (operator 
  90.        (getf (cddr whole) :operator type)))
  91.     (make-top-level-form `(define-method-combination ,type)
  92.              '(load eval)
  93.       `(load-short-defcombin
  94.      ',type ',operator ',identity-with-one-arg ',documentation))))
  95.  
  96. (defun load-short-defcombin (type operator ioa doc)
  97.   (let* ((truename (load-truename))
  98.      (specializers
  99.        (list (find-class 'generic-function)
  100.          (intern-eql-specializer type)
  101.          *the-class-t*))
  102.      (old-method
  103.        (get-method #'find-method-combination () specializers nil))
  104.      (new-method nil))
  105.     (setq new-method
  106.       (make-instance 'standard-method
  107.         :qualifiers ()
  108.         :specializers specializers
  109.         :lambda-list '(generic-function type options)
  110.         :function #'(lambda (gf type options)
  111.               (declare (ignore gf))
  112.               (do-short-method-combination
  113.                 type options operator ioa new-method doc))
  114.         :definition-source `((define-method-combination ,type) ,truename)))
  115.     (when old-method
  116.       (remove-method #'find-method-combination old-method))
  117.     (add-method #'find-method-combination new-method)))
  118.  
  119. (defun do-short-method-combination (type options operator ioa method doc)
  120.   (cond ((null options) (setq options '(:most-specific-first)))
  121.     ((equal options '(:most-specific-first)))
  122.     ((equal options '(:most-specific-last)))
  123.     (t
  124.      (method-combination-error
  125.        "Illegal options to a short method combination type.~%~
  126.             The method combination type ~S accepts one option which~%~
  127.             must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
  128.        type)))
  129.   (make-instance 'short-method-combination
  130.          :type type
  131.          :options options
  132.          :operator operator
  133.          :identity-with-one-argument ioa
  134.          :definition-source method
  135.          :documentation doc))
  136.  
  137. (defmethod compute-effective-method ((generic-function generic-function)
  138.                      (combin short-method-combination)
  139.                      applicable-methods)
  140.   (let ((type (method-combination-type combin))
  141.     (operator (short-combination-operator combin))
  142.     (ioa (short-combination-identity-with-one-argument combin))
  143.     (around ())
  144.     (primary ()))
  145.     (dolist (m applicable-methods)
  146.       (let ((qualifiers (method-qualifiers m)))
  147.     (flet ((lose (method why)
  148.          (invalid-method-error
  149.            method
  150.            "The method ~S ~A.~%~
  151.                     The method combination type ~S was defined with the~%~
  152.                     short form of DEFINE-METHOD-COMBINATION and so requires~%~
  153.                     all methods have either the single qualifier ~S or the~%~
  154.                     single qualifier :AROUND."
  155.            method why type type)))
  156.       (cond ((null qualifiers)
  157.          (lose m "has no qualifiers"))
  158.         ((cdr qualifiers)
  159.          (lose m "has more than one qualifier"))
  160.         ((eq (car qualifiers) :around)
  161.          (push m around))
  162.         ((eq (car qualifiers) type)
  163.          (push m primary))
  164.         (t
  165.          (lose m "has an illegal qualifier"))))))
  166.     (setq around (nreverse around)
  167.       primary (nreverse primary))
  168.     (let ((main-method
  169.         (if (and (null (cdr primary))
  170.              (not (null ioa)))
  171.         `(call-method ,(car primary) ())
  172.         `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
  173.                       primary)))))
  174.       (cond ((null primary)
  175.          `(error "No ~S methods for the generic function ~S."
  176.              ',type ',generic-function))
  177.         ((null around) main-method)
  178.         (t
  179.          `(call-method ,(car around)
  180.                (,@(cdr around) (make-method ,main-method))))))))
  181.  
  182.  
  183. ;;;
  184. ;;; long method combinations
  185. ;;;
  186. ;;;
  187.  
  188. (defclass long-method-combination (standard-method-combination)
  189.      ((function :initarg :function
  190.         :reader long-method-combination-function)))
  191.  
  192. (defun expand-long-defcombin (form)
  193.   (let ((type (cadr form))
  194.     (lambda-list (caddr form))
  195.     (method-group-specifiers (cadddr form))
  196.     (body (cddddr form))
  197.     (arguments-option ())
  198.     (gf-var nil))
  199.     (when (and (consp (car body)) (eq (caar body) :arguments))
  200.       (setq arguments-option (cdr (pop body))))
  201.     (when (and (consp (car body)) (eq (caar body) :generic-function))
  202.       (setq gf-var (cadr (pop body))))
  203.     (multiple-value-bind (documentation function)
  204.     (make-long-method-combination-function
  205.       type lambda-list method-group-specifiers arguments-option gf-var
  206.       body)
  207.       (make-top-level-form `(define-method-combination ,type)
  208.                '(load eval)
  209.     `(load-long-defcombin ',type ',documentation #',function)))))
  210.  
  211. (defvar *long-method-combination-functions* (make-hash-table :test #'eq))
  212.  
  213. (defun load-long-defcombin (type doc function)
  214.   (let* ((specializers
  215.        (list (find-class 'generic-function)
  216.          (intern-eql-specializer type)
  217.          *the-class-t*))
  218.      (old-method
  219.        (get-method #'find-method-combination () specializers nil))
  220.      (new-method
  221.        (make-instance 'standard-method
  222.          :qualifiers ()
  223.          :specializers specializers
  224.          :lambda-list '(generic-function type options)
  225.          :function #'(lambda (generic-function type options)
  226.                (declare (ignore generic-function))
  227.                (make-instance 'long-method-combination
  228.                  :type type
  229.                  :documentation doc
  230.                  :options options))
  231.          :definition-source `((define-method-combination ,type)
  232.                   ,(load-truename)))))
  233.     (setf (gethash type *long-method-combination-functions*) function)
  234.     (when old-method (remove-method #'find-method-combination old-method))
  235.     (add-method #'find-method-combination new-method)))
  236.  
  237. (defmethod compute-effective-method ((generic-function generic-function)
  238.                      (combin long-method-combination)
  239.                      applicable-methods)
  240.   (funcall (gethash (method-combination-type combin)
  241.             *long-method-combination-functions*)
  242.        generic-function
  243.        combin
  244.        applicable-methods))
  245.  
  246. ;;;
  247. ;;;
  248. ;;;
  249. (defun make-long-method-combination-function
  250.        (type ll method-group-specifiers arguments-option gf-var body)
  251.   ;;(declare (values documentation function))
  252.   (declare (ignore type))
  253.   (multiple-value-bind (documentation declarations real-body)
  254.       (extract-declarations body)
  255.  
  256.     (let ((wrapped-body
  257.         (wrap-method-group-specifier-bindings method-group-specifiers
  258.                           declarations
  259.                           real-body)))
  260.       (when gf-var
  261.     (push `(,gf-var .generic-function.) (cadr wrapped-body)))
  262.       
  263.       (when arguments-option
  264.     (setq wrapped-body (deal-with-arguments-option wrapped-body
  265.                                arguments-option)))
  266.  
  267.       (when ll
  268.     (setq wrapped-body
  269.           `(apply #'(lambda ,ll ,wrapped-body)
  270.               (method-combination-options .method-combination.))))
  271.  
  272.       (values
  273.     documentation
  274.     `(lambda (.generic-function. .method-combination. .applicable-methods.)
  275.        (progn .generic-function. .method-combination. .applicable-methods.)
  276.        (block .long-method-combination-function. ,wrapped-body))))))
  277. ;;
  278. ;; parse-method-group-specifiers parse the method-group-specifiers
  279. ;;
  280.  
  281. (defun wrap-method-group-specifier-bindings
  282.        (method-group-specifiers declarations real-body)
  283.   (with-gathering ((names (collecting))
  284.            (specializer-caches (collecting))
  285.            (cond-clauses (collecting))
  286.            (required-checks (collecting))
  287.            (order-cleanups (collecting)))
  288.       (dolist (method-group-specifier method-group-specifiers)
  289.     (multiple-value-bind (name tests description order required)
  290.         (parse-method-group-specifier method-group-specifier)
  291.       (declare (ignore description))
  292.       (let ((specializer-cache (gensym)))
  293.         (gather name names)
  294.         (gather specializer-cache specializer-caches)
  295.         (gather `((or ,@tests)
  296.               (if  (equal ,specializer-cache .specializers.)
  297.                (return-from .long-method-combination-function.
  298.                  '(error "More than one method of type ~S ~
  299.                                       with the same specializers."
  300.                      ',name))
  301.                (setq ,specializer-cache .specializers.))
  302.               (push .method. ,name))
  303.             cond-clauses)
  304.         (when required
  305.           (gather `(when (null ,name)
  306.              (return-from .long-method-combination-function.
  307.                '(error "No ~S methods." ',name)))
  308.               required-checks))
  309.         (loop (unless (and (constantp order)
  310.                    (neq order (setq order (eval order))))
  311.             (return t)))
  312.         (gather (cond ((eq order :most-specific-first)
  313.                `(setq ,name (nreverse ,name)))
  314.               ((eq order :most-specific-last) ())
  315.               (t
  316.                `(ecase ,order
  317.                   (:most-specific-first
  318.                 (setq ,name (nreverse ,name)))
  319.                   (:most-specific-last))))
  320.             order-cleanups))))
  321.    `(let (,@names ,@specializer-caches)
  322.       ,@declarations
  323.       (dolist (.method. .applicable-methods.)
  324.     (let ((.qualifiers. (method-qualifiers .method.))
  325.           (.specializers. (method-specializers .method.)))
  326.       (progn .qualifiers. .specializers.)
  327.       (cond ,@cond-clauses)))
  328.       ,@required-checks
  329.       ,@order-cleanups
  330.       ,@real-body)))
  331.    
  332. (defun parse-method-group-specifier (method-group-specifier)
  333.   ;;(declare (values name tests description order required))
  334.   (let* ((name (pop method-group-specifier))
  335.      (patterns ())
  336.      (tests 
  337.        (gathering1 (collecting)
  338.          (block collect-tests
  339.            (loop
  340.          (if (or (null method-group-specifier)
  341.              (memq (car method-group-specifier)
  342.                    '(:description :order :required)))
  343.              (return-from collect-tests t)
  344.              (let ((pattern (pop method-group-specifier)))
  345.                (push pattern patterns)
  346.                (gather1 (parse-qualifier-pattern name pattern)))))))))
  347.     (values name
  348.         tests
  349.         (getf method-group-specifier :description
  350.           (make-default-method-group-description patterns))
  351.         (getf method-group-specifier :order :most-specific-first)
  352.         (getf method-group-specifier :required nil))))
  353.  
  354. (defun parse-qualifier-pattern (name pattern)
  355.   (cond ((eq pattern '()) `(null .qualifiers.))
  356.     ((eq pattern '*) 't)
  357.     ((symbolp pattern) `(,pattern .qualifiers.))
  358.     ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
  359.     (t (error "In the method group specifier ~S,~%~
  360.                    ~S isn't a valid qualifier pattern."
  361.           name pattern))))
  362.  
  363. (defun qualifier-check-runtime (pattern qualifiers)
  364.   (loop (cond ((and (null pattern) (null qualifiers))
  365.            (return t))
  366.           ((eq pattern '*) (return t))
  367.           ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
  368.            (pop pattern)
  369.            (pop qualifiers))          
  370.           (t (return nil)))))
  371.  
  372. (defun make-default-method-group-description (patterns)
  373.   (if (cdr patterns)
  374.       (format nil
  375.           "methods matching one of the patterns: ~{~S, ~} ~S"
  376.           (butlast patterns) (car (last patterns)))
  377.       (format nil
  378.           "methods matching the pattern: ~S"
  379.           (car patterns))))
  380.  
  381.  
  382.  
  383. ;;;
  384. ;;; This baby is a complete mess.  I can't believe we put it in this
  385. ;;; way.  No doubt this is a large part of what drives MLY crazy.
  386. ;;;
  387. ;;; At runtime (when the effective-method is run), we bind an intercept
  388. ;;; lambda-list to the arguments to the generic function.
  389. ;;; 
  390. ;;; At compute-effective-method time, the symbols in the :arguments
  391. ;;; option are bound to the symbols in the intercept lambda list.
  392. ;;;
  393. (defun deal-with-arguments-option (wrapped-body arguments-option)
  394.   (let* ((intercept-lambda-list
  395.        (gathering1 (collecting)
  396.          (dolist (arg arguments-option)
  397.            (if (memq arg lambda-list-keywords)
  398.            (gather1 arg)
  399.            (gather1 (gensym))))))
  400.      (intercept-rebindings
  401.        (gathering1 (collecting)
  402.          (iterate ((arg (list-elements arguments-option))
  403.                (int (list-elements intercept-lambda-list)))
  404.            (unless (memq arg lambda-list-keywords)
  405.          (gather1 `(,arg ',int)))))))
  406.     ;;
  407.     ;;
  408.     (setf (cadr wrapped-body)
  409.       (append intercept-rebindings (cadr wrapped-body)))
  410.     ;;
  411.     ;; Be sure to fill out the intercept lambda list so that it can
  412.     ;; be too short if it wants to.
  413.     ;; 
  414.     (cond ((memq '&rest intercept-lambda-list))
  415.       ((memq '&allow-other-keys intercept-lambda-list))
  416.       ((memq '&key intercept-lambda-list)
  417.        (setq intercept-lambda-list
  418.          (append intercept-lambda-list '(&allow-other-keys))))
  419.       (t
  420.        (setq intercept-lambda-list
  421.          (append intercept-lambda-list '(&rest .ignore.)))))
  422.  
  423.     `(let ((inner-result. ,wrapped-body))
  424.        `(apply #'(lambda ,',intercept-lambda-list
  425.            ,,(when (memq '.ignore. intercept-lambda-list)
  426.                ''(declare (ignore .ignore.)))
  427.            ,inner-result.)
  428.            .combined-method-args.))))
  429.  
  430.  
  431.